home *** CD-ROM | disk | FTP | other *** search
/ PD ROM 1 / PD ROM Volume I - Macintosh Software from BMUG (1988).iso / Programming / FORTH Folder / Text files / string.4th < prev    next >
Encoding:
Text File  |  1984-07-16  |  5.1 KB  |  147 lines  |  [TEXT/ttxt]
  1.  
  2. SCR # 1
  3. ( String Routines:  $CONSTANT  $VARIABLE )       ( 051584 amf )
  4.  
  5. : $CONSTANT    ( $addr --        :@ compile
  6.                        -- $addr  :@ runtime )
  7.     CREATE  DUP C@ >R  R@ C,     ( Make header, store max cnt )
  8.        HERE R@ 1+ CMOVE          ( Move string past header )
  9.        R> 1+ ALLOT  ?ALIGN       ( Move DP past string, align )
  10.     DOES>  1+  ;                 ( Skip max cnt on execution )
  11.  
  12. : $VARIABLE    ( #bytes --       :@ compile
  13.                         -- $addr :@ runtime )
  14.     CREATE  DUP C,  0 C,         ( Store max cnt, set to null )
  15.        ALLOT   ?ALIGN            ( Allot max cnt bytes, align )
  16.     DOES>  1+  ;                 ( Skip max cnt on execution )
  17.  
  18. DECIMAL -->
  19.  
  20. SCR # 2
  21. ( Strings cont:  $!  $TOPAD )                    ( 051684 amf )
  22.  
  23. : $!           ( $from/$to --  )
  24.     DUP 1- C@                    ( Destination max byte count )
  25.     3 PICK C@                    ( Source string length )
  26.     MIN                          ( Clip to max cnt )
  27.     OVER >R DUP >R               ( Save new length and $address)    1+ CMOVE                     ( Move source to destination )
  28.     R> R> C!  ;                  ( Set length byte )
  29.  
  30. : $TOPAD       ( $addr -- PAD  :Move string to PAD if not there)    DUP PAD = NOT IF             ( At PAD already? )
  31.        PAD $!  PAD               ( If not, move it there )
  32.     THEN  ;
  33.  
  34. DECIMAL -->
  35.  
  36. SCR # 3
  37. ( Strings cont:  $+ )                            ( 051684 amf )
  38.  
  39. : $+           ( $addr1/$addr2 -- PAD )
  40.     SWAP DUP PAD = NOT IF        ( Is $1 at PAD? )
  41.        $TOPAD DROP               ( If not, move it there )
  42.     ELSE
  43.        DROP                      ( Otherwise we're ok )
  44.     THEN
  45.     PAD DUP C@ 1+ + SWAP         ( Find the end of $1 )
  46.     PAD 256 +  3 PICK -  OVER C@ MIN      ( How much to move )
  47.     >R  1+ SWAP R@ CMOVE         ( Move $2 onto end of $1 )
  48.     R>  PAD C@ +  PAD C!  PAD ;  ( Update length, leave $addr )
  49.  
  50. DECIMAL -->
  51.  
  52. SCR # 4
  53. ( Strings cont:  RIGHT$  LEFT$  $. )   HEX       ( 051684 amf )
  54.  
  55. : RIGHT$       ( $addr/n -- PAD )
  56.     SWAP $TOPAD                  ( Move it to PAD )
  57.     OVER  PAD C@  < IF           ( Make sure n < string length )       OVER  PAD COUNT  + SWAP -      ( Get start addr of sub$ )       PAD 1+  4 PICK  CMOVE  C!  PAD     ( Move sub$ to PAD+1 )    ELSE
  58.        SWAP DROP                 ( If n > $length, leave $addr )    THEN  ;
  59.  
  60. : LEFT$        ( $addr/n -- PAD )
  61.     SWAP $TOPAD  C@ MIN  PAD C!  PAD  ;  ( You figure it out...)
  62. : $.   ( $addr --  )   COUNT TYPE  ;
  63. -->
  64.  
  65. SCR # 5
  66. ( Strings cont:  MID$  LEN )                     ( 051684 amf )
  67.  
  68. : MID$         ( $addr/startpos/#chr -- PAD )
  69.     ROT $TOPAD               ( Move to PAD )
  70.     C@  3 PICK -  0<         ( Check if startpos > $length )
  71.     3 PICK 0=  OR            ( Or startpos = 0 )
  72.     OVER 0=  OR  IF          ( Or #chr = 0 )
  73.        2DROP  0 PAD C!       ( If so, leave null string )
  74.     ELSE                     ( Clip #chr to $length - startpos )       OVER  PAD C@ 1+  SWAP - MIN
  75.        SWAP PAD +  OVER PAD 1+ SWAP  CMOVE ( Move sub$ to PAD+1)       PAD C!                ( Set new length )
  76.     THEN   PAD  ;
  77.  
  78. : LEN   ( $addr -- len )   C@  ;
  79. -->
  80.  
  81. SCR # 6
  82. ( Strings cont:  ASC  NUL$  CHR$ )               ( 051684 amf )
  83.  
  84. : ASC          ( $addr -- n )
  85.     DUP C@ IF
  86.        1+ C@
  87.     ELSE
  88.        ." NULL STRING "  DROP 0
  89.     THEN  ;
  90.  
  91. : NUL$   ( $addr --  )   0 SWAP C!  ;
  92.  
  93. : CHR$         ( n -- PAD )
  94.     PAD 1+ C!  1 PAD C!  PAD  ;
  95.  
  96. -->
  97.  
  98. SCR # 7
  99. ( Strings cont:  $COMPARE  VAL )    HEX          ( 051684 amf )
  100.  
  101. : $COMPARE     ( $addr1/$addr2 -- flag )
  102.     OVER C@  OVER C@  2DUP - >R    ( Save length difference )
  103.     MIN  ROT 1+   ROT 1+  ROT SWAP  -TEXT    ( Compare $s )
  104.     ?DUP 0= IF                     ( If they are the same... )
  105.        R> DUP IF                   (  and they differ in length)          0< IF -1 ELSE 1 THEN     ( Leave sign of difference )
  106.        THEN
  107.     ELSE
  108.        R>DROP                      ( Else leave -TEXT flag )
  109.     THEN  ;
  110.  
  111. : VAL          ( $addr -- n )
  112.     $TOPAD  PAD NUMBER  ;          ( Convert it to a number! )
  113. -->
  114.  
  115. SCR # 8
  116. ( Strings cont:  <$  $=  $>  STR$ )   HEX        ( 051684 amf )
  117.  
  118. : $<   $COMPARE 0<  ;
  119.  
  120. : $=   $COMPARE 0=  ;
  121.  
  122. : $>   $COMPARE 0>  ;
  123.  
  124. : STR$         ( n -- PAD )
  125.     DUP ABS  <# #S              ( Save sign, convert unsigned #)    SWAP  0< IF 2D ELSE 20 THEN  HOLD  #>     ( Minus or space )    >R  PAD 1+ R@ CMOVE         ( Move string to PAD )
  126.     R> PAD C!  PAD  ;           ( Set max cnt byte )
  127.  
  128. -->
  129.  
  130. SCR # 9
  131. ( Strings cont:  POS$  INPUT$ )                  ( 051684 amf )
  132.  
  133. : POS$         ( $substring/$dest -- pos )
  134.     DUP >R                            ( Save destination $addr )    COUNT  ROT COUNT DUP >R  MATCH    ( Save substring length )
  135.     SWAP 0= IF                        ( 0 if match )
  136.        R> -  R> -               ( Subtract substring length $ )
  137.     ELSE                        (   dest $addr to get offset )
  138.        R>DROP R>DROP DROP 0     ( Else leave no match flag )
  139.     THEN  ;
  140.  
  141. : INPUT$       ( $addr --  )
  142.     PAD 255 INPUT.STRING        ( Input maximum length string )
  143.     DUP 1- C@  PAD C@  MIN PAD C!  ( Clip input string length )
  144.     PAD SWAP $!  ;              ( Move input to destination $ )
  145.  
  146.  
  147. XA 4: